home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / src / tclLink.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-25  |  11.0 KB  |  366 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCL_LINK
  3. #endif
  4.  
  5. /* 
  6.  * tclLink.c --
  7.  *
  8.  *    This file implements linked variables (a C variable that is
  9.  *    tied to a Tcl variable).  The idea of linked variables was
  10.  *    first suggested by Andreas Stocke and this implementation is
  11.  *    based heavily on a prototype implementation provided by
  12.  *    him.
  13.  *
  14.  * Copyright (c) 1993 The Regents of the University of California.
  15.  * All rights reserved.
  16.  *
  17.  * Permission is hereby granted, without written agreement and without
  18.  * license or royalty fees, to use, copy, modify, and distribute this
  19.  * software and its documentation for any purpose, provided that the
  20.  * above copyright notice and the following two paragraphs appear in
  21.  * all copies of this software.
  22.  * 
  23.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  24.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  25.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  26.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27.  *
  28.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  29.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  30.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  31.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  32.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  33.  */
  34.  
  35. #ifndef lint
  36. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclLink.c,v 1.4 93/07/29 15:24:05 ouster Exp $ SPRITE (Berkeley)";
  37. #endif /* not lint */
  38.  
  39. #include "tclInt.h"
  40.  
  41. /*
  42.  * For each linked variable there is a data structure of the following
  43.  * type, which describes the link and is the clientData for the trace
  44.  * set on the Tcl variable.
  45.  */
  46.  
  47. typedef struct Link {
  48.     Tcl_Interp *interp;        /* Interpreter containing Tcl variable. */
  49.     char *addr;            /* Location of C variable. */
  50.     int type;            /* Type of link (TCL_LINK_INT, etc.). */
  51.     int writable;        /* Zero means Tcl variable is read-only. */
  52.     union {
  53.     int i;
  54.     double d;
  55.     } lastValue;        /* Last known value of C variable;  used to
  56.                  * avoid string conversions. */
  57. } Link;
  58.  
  59. /*
  60.  * Forward references to procedures defined later in this file:
  61.  */
  62.  
  63. static char *        LinkTraceProc _ANSI_ARGS_((ClientData clientData,
  64.                 Tcl_Interp *interp, char *name1, char *name2,
  65.                 int flags));
  66. static char *        StringValue _ANSI_ARGS_((Link *linkPtr,
  67.                 char *buffer));
  68.  
  69. /*
  70.  *----------------------------------------------------------------------
  71.  *
  72.  * Tcl_LinkVar --
  73.  *
  74.  *    Link a C variable to a Tcl variable so that changes to either
  75.  *    one causes the other to change.
  76.  *
  77.  * Results:
  78.  *    The return value is TCL_OK if everything went well or TCL_ERROR
  79.  *    if an error occurred (interp->result is also set after errors).
  80.  *
  81.  * Side effects:
  82.  *    The value at *addr is linked to the Tcl variable "varName",
  83.  *    using "type" to convert between string values for Tcl and
  84.  *    binary values for *addr.
  85.  *
  86.  *----------------------------------------------------------------------
  87.  */
  88.  
  89. int
  90. Tcl_LinkVar(interp, varName, addr, type)
  91.     Tcl_Interp *interp;        /* Interpreter in which varName exists. */
  92.     char *varName;        /* Name of a global variable in interp. */
  93.     char *addr;            /* Address of a C variable to be linked
  94.                  * to varName. */
  95.     int type;            /* Type of C variable: TCL_LINK_INT, etc. 
  96.                  * Also may have TCL_LINK_READ_ONLY
  97.                  * OR'ed in. */
  98. {
  99.     Link *linkPtr;
  100.     char buffer[TCL_DOUBLE_SPACE];
  101.     int code;
  102.  
  103.     linkPtr = (Link *) ckalloc(sizeof(Link));
  104.     linkPtr->interp = interp;
  105.     linkPtr->addr = addr;
  106.     linkPtr->type = type & ~TCL_LINK_READ_ONLY;
  107.     linkPtr->writable = (type & TCL_LINK_READ_ONLY) == 0;
  108.     if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer),
  109.         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
  110.     ckfree((char *) linkPtr);
  111.     return TCL_ERROR;
  112.     }
  113.     code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
  114.         |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
  115.         (ClientData) linkPtr);
  116.     if (code != TCL_OK) {
  117.     ckfree((char *) linkPtr);
  118.     }
  119.     return code;
  120. }
  121.  
  122. /*
  123.  *----------------------------------------------------------------------
  124.  *
  125.  * Tcl_UnlinkVar --
  126.  *
  127.  *    Destroy the link between a Tcl variable and a C variable.
  128.  *
  129.  * Results:
  130.  *    None.
  131.  *
  132.  * Side effects:
  133.  *    If "varName" was previously linked to a C variable, the link
  134.  *    is broken to make the variable independent.  If there was no
  135.  *    previous link for "varName" then nothing happens.
  136.  *
  137.  *----------------------------------------------------------------------
  138.  */
  139.  
  140. void
  141. Tcl_UnlinkVar(interp, varName)
  142.     Tcl_Interp *interp;        /* Interpreter containing variable to unlink. */
  143.     char *varName;        /* Global variable in interp to unlink. */
  144. {
  145.     Link *linkPtr;
  146.  
  147.     linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
  148.         LinkTraceProc, (ClientData) NULL);
  149.     if (linkPtr == NULL) {
  150.     return;
  151.     }
  152.     Tcl_UntraceVar(interp, varName,
  153.         TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  154.         LinkTraceProc, (ClientData) linkPtr);
  155.     ckfree((char *) linkPtr);
  156. }
  157.  
  158. /*
  159.  *----------------------------------------------------------------------
  160.  *
  161.  * LinkTraceProc --
  162.  *
  163.  *    This procedure is invoked when a linked Tcl variable is read,
  164.  *    written, or unset from Tcl.  It's responsible for keeping the
  165.  *    C variable in sync with the Tcl variable.
  166.  *
  167.  * Results:
  168.  *    If all goes well, NULL is returned; otherwise an error message
  169.  *    is returned.
  170.  *
  171.  * Side effects:
  172.  *    The C variable may be updated to make it consistent with the
  173.  *    Tcl variable, or the Tcl variable may be overwritten to reject
  174.  *    a modification.
  175.  *
  176.  *----------------------------------------------------------------------
  177.  */
  178.  
  179. static char *
  180. LinkTraceProc(clientData, interp, name1, name2, flags)
  181.     ClientData clientData;    /* Contains information about the link. */
  182.     Tcl_Interp *interp;        /* Interpreter containing Tcl variable. */
  183.     char *name1;        /* First part of variable name. */
  184.     char *name2;        /* Second part of variable name. */
  185.     int flags;            /* Miscellaneous additional information. */
  186. {
  187.     Link *linkPtr = (Link *) clientData;
  188.     int changed;
  189.     char buffer[TCL_DOUBLE_SPACE];
  190.     char *value, **pp;
  191.     Tcl_DString savedResult;
  192.  
  193.     /*
  194.      * If the variable is being unset, then just re-create it (with a
  195.      * trace) unless the whole interpreter is going away.
  196.      */
  197.  
  198.     if (flags & TCL_TRACE_UNSETS) {
  199.     if (flags & TCL_INTERP_DESTROYED) {
  200.         ckfree((char *) linkPtr);
  201.     }
  202.     if (flags & TCL_TRACE_DESTROYED) {
  203.         Tcl_SetVar2(interp, name1, name2,
  204.             StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
  205.         Tcl_TraceVar2(interp, name1, name2, TCL_GLOBAL_ONLY
  206.             |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  207.             LinkTraceProc, (ClientData) linkPtr);
  208.     }
  209.     return NULL;
  210.     }
  211.  
  212.     /*
  213.      * For read accesses, update the Tcl variable if the C variable
  214.      * has changed since the last time we updated the Tcl variable.
  215.      */
  216.  
  217.     if (flags & TCL_TRACE_READS) {
  218.     switch (linkPtr->type) {
  219.         case TCL_LINK_INT:
  220.         case TCL_LINK_BOOLEAN:
  221.         changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
  222.         break;
  223.         case TCL_LINK_DOUBLE:
  224.         changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
  225.         break;
  226.         case TCL_LINK_STRING:
  227.         changed = 1;
  228.         break;
  229.         default:
  230.         return "internal error: bad linked variable type";
  231.     }
  232.     if (changed) {
  233.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  234.             TCL_GLOBAL_ONLY);
  235.     }
  236.     return NULL;
  237.     }
  238.  
  239.     /*
  240.      * For writes, first make sure that the variable is writable.  Then
  241.      * convert the Tcl value to C if possible.  If the variable isn't
  242.      * writable or can't be converted, then restore the varaible's old
  243.      * value and return an error.  Another tricky thing: we have to save
  244.      * and restore the interpreter's result, since the variable access
  245.      * could occur when the result has been partially set.
  246.      */
  247.  
  248.     if (!linkPtr->writable) {
  249.     Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  250.             TCL_GLOBAL_ONLY);
  251.     return "linked variable is read-only";
  252.     }
  253.     value = Tcl_GetVar2(interp, name1, name2, TCL_GLOBAL_ONLY);
  254.     if (value == NULL) {
  255.     /*
  256.      * This shouldn't ever happen.
  257.      */
  258.     return "internal error: linked variable couldn't be read";
  259.     }
  260.     Tcl_DStringInit(&savedResult);
  261.     Tcl_DStringAppend(&savedResult, interp->result, -1);
  262.     Tcl_ResetResult(interp);
  263.     switch (linkPtr->type) {
  264.     case TCL_LINK_INT:
  265.         if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) {
  266.         Tcl_DStringResult(interp, &savedResult);
  267.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  268.             TCL_GLOBAL_ONLY);
  269.         return "variable must have integer value";
  270.         }
  271.         *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
  272.         break;
  273.     case TCL_LINK_DOUBLE:
  274.         if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d)
  275.             != TCL_OK) {
  276.         Tcl_DStringResult(interp, &savedResult);
  277.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  278.             TCL_GLOBAL_ONLY);
  279.         return "variable must have real value";
  280.         }
  281.         *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
  282.         break;
  283.     case TCL_LINK_BOOLEAN:
  284.         if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i)
  285.             != TCL_OK) {
  286.         Tcl_DStringResult(interp, &savedResult);
  287.         Tcl_SetVar2(interp, name1, name2, StringValue(linkPtr, buffer),
  288.             TCL_GLOBAL_ONLY);
  289.         return "variable must have boolean value";
  290.         }
  291.         *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
  292.         break;
  293.     case TCL_LINK_STRING:
  294.         pp = (char **)(linkPtr->addr);
  295.         if (*pp != NULL) {
  296.         ckfree(*pp);
  297.         }
  298.         *pp = ckalloc((unsigned) (strlen(value) + 1));
  299.         strcpy(*pp, value);
  300.         break;
  301.     default:
  302.         return "internal error: bad linked variable type";
  303.     }
  304.     Tcl_DStringResult(interp, &savedResult);
  305.     return NULL;
  306. }
  307.  
  308. /*
  309.  *----------------------------------------------------------------------
  310.  *
  311.  * StringValue --
  312.  *
  313.  *    Converts the value of a C variable to a string for use in a
  314.  *    Tcl variable to which it is linked.
  315.  *
  316.  * Results:
  317.  *    The return value is a pointer
  318.  to a string that represents
  319.  *    the value of the C variable given by linkPtr.
  320.  *
  321.  * Side effects:
  322.  *    None.
  323.  *
  324.  *----------------------------------------------------------------------
  325.  */
  326.  
  327. static char *
  328. StringValue(linkPtr, buffer)
  329.     Link *linkPtr;        /* Structure describing linked variable. */
  330.     char *buffer;        /* Small buffer to use for converting
  331.                  * values.  Must have TCL_DOUBLE_SPACE
  332.                  * bytes or more. */
  333. {
  334.     char *p;
  335.  
  336.     switch (linkPtr->type) {
  337.     case TCL_LINK_INT:
  338.         linkPtr->lastValue.i = *(int *)(linkPtr->addr);
  339.         sprintf(buffer, "%d", linkPtr->lastValue.i);
  340.         return buffer;
  341.     case TCL_LINK_DOUBLE:
  342.         linkPtr->lastValue.d = *(double *)(linkPtr->addr);
  343.         Tcl_PrintDouble(linkPtr->interp, linkPtr->lastValue.d, buffer);
  344.         return buffer;
  345.     case TCL_LINK_BOOLEAN:
  346.         linkPtr->lastValue.i = *(int *)(linkPtr->addr);
  347.         if (linkPtr->lastValue.i != 0) {
  348.         return "1";
  349.         }
  350.         return "0";
  351.     case TCL_LINK_STRING:
  352.         p = *(char **)(linkPtr->addr);
  353.         if (p == NULL) {
  354.         return "NULL";
  355.         }
  356.         return p;
  357.     }
  358.  
  359.     /*
  360.      * This code only gets executed if the link type is unknown
  361.      * (shouldn't ever happen).
  362.      */
  363.  
  364.     return "??";
  365. }
  366.